home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / gnu / emacs.lha / emacs-19.16 / lisp / undigest.el < prev    next >
Lisp/Scheme  |  1992-09-21  |  4KB  |  115 lines
  1. ;;; undigest.el --- digest-cracking support for the RMAIL mail reader
  2.  
  3. ;; Copyright (C) 1985, 1986 Free Software Foundation, Inc.
  4.  
  5. ;; Maintainer: FSF
  6. ;; Keywords: mail
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  22. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23.  
  24. ;;; Commentary:
  25.  
  26. ;; See Internet RFC 934
  27.  
  28. ;;; Code:
  29.  
  30. (defun undigestify-rmail-message ()
  31.   "Break up a digest message into its constituent messages.
  32. Leaves original message, deleted, before the undigestified messages."
  33.   (interactive)
  34.   (widen)
  35.   (let ((buffer-read-only nil)
  36.     (msg-string (buffer-substring (rmail-msgbeg rmail-current-message)
  37.                       (rmail-msgend rmail-current-message))))
  38.     (goto-char (rmail-msgend rmail-current-message))
  39.     (narrow-to-region (point) (point))
  40.     (insert msg-string)
  41.     (narrow-to-region (point-min) (1- (point-max))))
  42.   (let ((error t)
  43.     (buffer-read-only nil))
  44.     (unwind-protect
  45.     (progn
  46.       (save-restriction
  47.         (goto-char (point-min))
  48.         (delete-region (point-min)
  49.                (progn (search-forward "\n*** EOOH ***\n")
  50.                   (point)))
  51.         (insert "\^_\^L\n0, unseen,,\n*** EOOH ***\n")
  52.         (narrow-to-region (point)
  53.                   (point-max))
  54.         (let* ((fill-prefix "")
  55.            (case-fold-search t)
  56.            (digest-name
  57.             (mail-strip-quoted-names
  58.              (or (save-restriction
  59.                (search-forward "\n\n")
  60.                (narrow-to-region (point-min) (point))
  61.                (goto-char (point-max))
  62.                (or (mail-fetch-field "Reply-To")
  63.                    (mail-fetch-field "To")
  64.                    (mail-fetch-field "Apparently-To")
  65.                    (mail-fetch-field "From")))
  66.              (error "Message is not a digest")))))
  67.           (save-excursion
  68.         (goto-char (point-max))
  69.         (skip-chars-backward " \t\n")
  70.         (let ((count 10) found)
  71.           ;; compensate for broken un*x digestifiers.  Sigh Sigh.
  72.           (while (and (> count 0) (not found))
  73.             (forward-line -1)
  74.             (setq count (1- count))
  75.             (if (looking-at (concat "End of.*Digest.*\n"
  76.                         (regexp-quote "*********") "*"
  77.                         "\\(\n------*\\)*"))
  78.             (setq found t)))
  79.           (if (not found) (error "Message is not a digest"))))
  80.           (re-search-forward (concat "^" (make-string 55 ?-) "-*\n*"))
  81.           (replace-match "\^_\^L\n0, unseen,,\n*** EOOH ***\n")
  82.           (save-restriction
  83.         (narrow-to-region (point)
  84.                   (progn (search-forward "\n\n")
  85.                      (point)))
  86.         (if (mail-fetch-field "To") nil
  87.           (goto-char (point-min))
  88.           (insert "To: " digest-name "\n")))
  89.           (while (re-search-forward
  90.               (concat "\n\n" (make-string 27 ?-) "-*\n*")
  91.               nil t)
  92.         (replace-match "\n\n\^_\^L\n0, unseen,,\n*** EOOH ***\n")
  93.         (save-restriction
  94.           (if (looking-at "End ")
  95.               (insert "To: " digest-name "\n\n")
  96.             (narrow-to-region (point)
  97.                       (progn (search-forward "\n\n"
  98.                                  nil 'move)
  99.                          (point))))
  100.           (if (mail-fetch-field "To") nil
  101.             (goto-char (point-min))
  102.             (insert "To: " digest-name "\n"))))))
  103.       (setq error nil)
  104.       (message "Message successfully undigestified")
  105.       (let ((n rmail-current-message))
  106.         (rmail-forget-messages)
  107.         (rmail-show-message n)
  108.         (rmail-delete-forward)))
  109.       (cond (error
  110.          (narrow-to-region (point-min) (1+ (point-max)))
  111.          (delete-region (point-min) (point-max))
  112.          (rmail-show-message rmail-current-message))))))
  113.  
  114. ;;; undigest.el ends here
  115.